perm filename MOVER.F4[1,MUS] blob sn#079893 filedate 1973-12-30 generic text, type T, neo UTF8
00100	C****  SUBR. MOVER     FUNC. RTLINE, EXTEN
00200		SUBROUTINE MOVER
00300		IMPLICIT INTEGER(A-Q,S-Z)
00400		DIMENSION R(2,200),IR(2,200)
00500		REAL PWDS,POS,EXTEN
00600		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(8),RSTJC
00700		COMMON/ALF/INP(72),ML/XRN/RN(4000)
00800		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00900		COMMON/POSI/STFF(8),JJB,POS/PTR/PWDS(250),ITEM,L,I,IX
01000	      EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
01100		1,(RJC,RJQ(1)),(RJH,RJQ(6)),(RJI,RJQ(7)),(RJK,RJQ(9))
01200		1,(IR,R,RN(3101))
01300		DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/,RSP/.5/
01400	
01500		JJB=-1
01600	CC	ROV=1000
01700		JB=0
01800	C  99=BACKUP
01900	6	CALL VLINE(RJC,RJD,RJE,RJF)
02000		IF(RJC.EQ.99)RETURN
02100		IF(INP(1).NE.'J')GO TO 12
02200		RRT=RJE
02300		RZRO=RJD
02400		IF(RRT.EQ.0)RRT=200
02500		IF(RZRO.EQ.0)RZRO=.001
02600		RCNT=0
02700		RJSZ=5.0
02800		ASK=-1
02900		RJG=RJC
03000		RJF=0
03100		RJK=0
03200	19	IF(RCNT.GT.9)GO TO 101
03300		ROV=RRT
03400		RJSZ=RJSZ-.1
03500		RCNT=RCNT+1
03600	C  TEMPORARY COUNTER
03700		ML=1
03800		TYPE F78F,RCNT
03900	
04000		DO 11 KN=-3,4
04100		RSPC=0
04200		RJH=KN
04300		N=0
04400		DO 2 K=1,ITEM
04500		L=PWDS(K)
04600		IF(RTLINE(L))GO TO 2
04700		RA=RN(L+1)
04800		RB=RN(L+2)
04900		IF((RN(L+3).NE.RJH.AND.RA.NE.4).OR.RB.LT.RZRO)GO TO 2
05000		IF(RA.NE.1)GO TO 27
05100	CC	IF(ABS(RN(L+6)).GE.2)GO TO 2
05200	C  SKIPS HOMED NOTES (IN CHORDS)
05300		GO TO 10
05400	27	IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
05500		IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
05600	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
05700	10	N=N+1
05800		R(1,N)=RB
05900		IR(2,N)=L
06000		IF(N.EQ.200)GO TO 28
06100	C  ONLY TREATS 100 ITEMS AT A TIME.
06200	2	CONTINUE
06300		IF(N.EQ.0)GO TO 11
06400	28	DO 23 K=1,N
06500	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
06600	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
06700		GO TO 11
06800	24	RSTJC=RSTFAC(KN+4)
06900	CC	N=N-1
07000		CALL SORT2(R,N)
07100	
07200	C  JUMP IF LAST IS A BAR LINE.
07300		K=0
07310		JLDGR=0
07400	     	JX=0
07500	22	K=K+1
07600	122	L=IR(2,K)
07700		RA=RN(L+1)
07800		RB=0
07900		RX=RN(L+5)
08000		RY=1
08100		RW=AMOD(RN(L+4),100.)
08200		IF(RA.GT.1)GO TO 4
08300		RZ=RN(L+7)
08325		IF(LDGR.NE.JLDGR)JLDGR=0
08350		LDGR=0
08400		JY=K
08500		DO 32 JJ=JY+1,N+1
08550		K=JJ
08600	32	IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
09000	C  FOUND HOW MANY MEMBERS TO CHORD.
09400	35	RB=0
09450		K=K-1
09500		RQ=0
09600		RD=0
09700	125	IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
09800		DO 37 JJ=JY,K-1
09850		IF(RD.NE.0)GO TO 38
09875	C FINDS ONLY HIGH OR! LOW LED. LINE.
09900		RW=AMOD(RN(IR(2,JJ)+4),100.)
10000		IF(RW.LE.11.AND.RW.GE.2)GO TO 38
10050		LDGR=-1
10100		IF(RW.GT.11)LDGR=1
10150		IF(JLDGR.EQ.LDGR)GO TO 36
10187		JLDGR=LDGR
10200	C LDGR IS FOR LEDGER LINES.
10225		GO TO 38
10250	CC36	JLDGR=0
10260	36	RD=1.5
10270		RQ=RD
10280	CC	LDGR=0
10300	38	IF(RB.GT.2)GO TO 222
10400	C  JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
10500		RZZ=RN(IR(2,JJ)+7)
10600		RE=RN(IR(2,JJ)+5)
10700		IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
10800		1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
10900	C  SPACE FOR DOT OR TAIL(IF STEM UP)
11000		IF(ABS(RN(IR(2,JJ)+6)).EQ.10)RB=RB+2
11100	C  FOR CHORD TONES ON RIGHT OF STEM UP.
11200	C  LOOKS THROUGH ALL NOTES OF A CHORD.
11300	222	IF(AMOD(RN(IR(2,JJ)+5),10.).EQ.0)GO TO 37 
11400	C  JUMP IF NO ACCIS.
11500	425	RD=2*RY+EXTEN(RN(IR(2,JJ)+5))
11600		IF(RQ.GT.RD)RD=RQ
11700		RQ=RD
11800	C  FUNCT. EXTEN=AMOD(X,1.)*10.
11900	37 	CONTINUE
12600	25	IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
12700		GO TO 17
12800	4	IF(RA.NE.3)GO TO 29
12900		RB=3
13000		IF(RX.GT.100)RB=1.5
13100	C  CHECK ON SIZE NEEDED FOR CLEFS
13200	29	IF(RA.NE.4)GO TO 26
13300		RB=-RJSZ/2
13400		RD=.9
13500		GO TO 25
13600	26	IF(RA.NE.18)GO TO 30
13700		IF(RW.GT.9.OR.RX.GT.9)GO TO 31
13710	C  CHECKS FOR 2-DIGIT METERS
13800		RB=-1
13900		RD=1
14000		GO TO 25
14100	31	RB=2
14200		RD=3
14300		GO TO 25
14400	30	IF(RA.NE.7)GO TO 17
14450	CC	RB=2*(ABS(RW)-2)
14455		RB=2*(ABS(RW)-1)-2
14475		RD=2
14487		GO TO 25
14500	C  SPACES FOR CORRECT NUM OF ACCIS.
14700	17	RC=(RB+RJSZ)*RSTJC
14800	C  RJSZ=DEFAULT SIZE
14900		JX=JX+1
15000		R(2,JX)=RC
15100		R(1,JX)=R(1,K)
15200	3	IF(K.LT.N)GO TO 22
15300		RA=R(1,1)
15400		RB=R(2,1)
15500	
15600		DO 13 KX=2,JX
15700		RE=R(1,KX)
15800	C  POS. BEFORE SHIFTING
15900		IF(ABS(RE-RA).GT..5)GO TO 14
16000		IF(R(2,KX).GT.RB)GO TO 16
16100	C  SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
16200		GO TO 13
16300	CC	IF(RZZ.LE.RB)GO TO 13
16400	C  JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
16500	CC	RB=RZZ-RB
16600	14	RD=RA+RB-RE
16700		IF(RD.LE.0)GO TO 16
16800	C  THERE'S ENOUGH ROOM
16900	CC	RD=RA+RB-RE+RD
17000		RJD=RE+RSPC-.001
17100		RJE=1000
17200		RJH=RD
17300		RJI=0
17400		RSPC=RSPC+RD
17500	C  RSPC SAVES TOTAL SPACE ADDED
17600	C  GO EXPAND IT
17700		IF(R(2,KX).NE.0)GO TO 166
17800	16	RB=R(2,KX)
17900	13	RA=RE
18000	11	CONTINUE
18100	110	IF(ROV.LE.RRT+.01)GO TO 18
18200		RJD=RZRO
18300		RJE=ROV
18400		RJH=RZRO
18500		RJI=RRT-.001
18600	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
18700		ML=3
18800		IF(RJSZ.GT.4)RJSZ=4
18900		GO TO 66
19000	18	ML=4
19100		RJH=ROV
19200		RJI=RRT+2
19300	C  GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
19400		RJD=ROV
19500		RJE=500
19600	166	JJB=-1
19700		JB=0
19800		GO TO 66
19900	12	TYPE 5
20000		ML=2
20100		ACCEPT F78F,RJG,RJH,RJI,RJK
20200		REREAD FA1,L
20300	C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
20400		IF(RJG.EQ.99)GO TO 6
20500		IF(L.NE.'L')GO TO 66
20600		DO 67 K=1,2
20700		RJH=RY
20800		CALL LPEN(RJG,RY,RX)
20900	67	IF(RJG.EQ.99)GO TO 6
21000		RJI=RY
21100	66	JY=1
21200		L=JY
21300		IF(INP(1).EQ.'C')L=I
21400	C  C=COPY
21500		RDIS=0
21600		IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
21700	
21800	6551	RB=RN(JY)
21900		JB=JB+1
22000		IF(RTLINE(JY))GO TO 7551
22100	C  IF STAFF#>4, ALL STAVES ARE MOVED.
22200		RA=RN(JY+1)
22300		IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
22400	C SKIPS IF NOT SPECIAL CODE NUM.
22500		RN2=RN(JY+2)
22600		IF(RN2.GT.RJE)GO TO 7551
22700		RC=-1
22800		RD=0
22900		IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
23000		IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
23100	C RC=0 FOR CODES 4,8,9
23200		RN6=RN(JY+6)
23300		IF(RN2.GE.RJD)GO TO 8
23400	      IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
23500	C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
23600	C  IF INP(1)='C' MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
23700	8	IF(ASK)GO TO 100
23800		CALL ASKIT
23900		IF(K.EQ.'N')GO TO 7551
24000		IF(K.EQ.'X')GO TO 1
24100	C  'X'=EXIT
24200	C  N=NO, <CR>=YES
24300	100	IF(INP(1).NE.'C')GO TO 9551
24400		K=RB+2
24500		CALL LOOP(0,K,1,L,JY,RN)
24600		ITEM=ITEM+1
24700		IF(JJB)JJB=ITEM
24800	C  JJB SAVES ITEM # FOR MAIN PROG.
24900		PWDS(ITEM+1)=L+K+1
25000	9551	IF(JJB)JJB=JB
25100	C   (50=CRESC., DECRESC.)
25200		IF(RJC.LT.5)RN(L+3)=RJG
25400		RQ6=RN6-RJE
25500		RX=0
25600		IF(RA.NE.9.OR.RB.LT.7)GO TO 21
25700		RX=RN(L+9)
25800		RY=RX-RJE
25900		RZ=RJD-RX
26000		IF(RY.AND.RZ)RX=-1
26100	C PARTIAL BEAM IS WITHIN MOVE AREA.
26200	21	IF(RJI.EQ.0)GO TO 2551
26300		IF(RN2.GE.RJD)RN(L+2)=RJH+(RN2-RJD)*RDIS
26400		IF(RC)GO TO 7552
26500		IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
26600		IF(RQ6)RN(L+6)=RJH+(RN(JY+6)-RJD)*RDIS 
26700	C  END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
26800		IF(RA.NE.9)GO TO 7552
26900		IF(RX)RN(L+9)=RJH+(RN(JY+9)-RJD)*RDIS
27000	C  ONLY TRUE WHEN RA=9
27100		GO TO 7552
27200	
27300	2551	IF(RN2.GE.RJD)RN2=RN2+RJH
27400		RN(L+2)=RN2
27500	      IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
27600		IF(RX)RN(L+9)=RN(JY+9)+RJH
27700		IF(RN2.GT.ROV)ROV=RN2
27800	C  NOT YET FIXED FOR ENDS OF SLURS OR LINES
27900	7552	L=RB+3+L
28000		IF(RJK.EQ.0)GO TO 7551
28100	1551	IF((RB.LT.3..AND.RA.NE.6.).OR.RA.EQ.18)GO TO 7551
28200	C  'U-D' SKIPS METER, STAFF, ETC.
28300		JX=JY
28400		IF(INP(1).EQ.'C')JX=PWDS(ITEM)
28500		RN(JX+4)=RN(JX+4)+RJK
28600		IF(RC.EQ.0)RN(JX+5)=RN(JX+5)+RJK
28700	7551	JY=RB+3+JY
28800		IF(INP(1).NE.'C')L=JY
28900		IF(JY.LT.I)GO TO 6551
29000		GO TO (16,1,19,101),ML
29100	101	JJB=1
29200	1	CALL HYDPOG(3)
29300	5	FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN #'/)
29400		END
29500	
29600		FUNCTION RTLINE(L)
29700		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
29800		RTLINE=-1
29900		IF(RJQ(1).GT.4.OR.RN(L+3).EQ.RJQ(1))RTLINE=0
30000		END
30100	
30200		FUNCTION EXTEN(X)
30300		EXTEN=AMOD(X,1.)*10.
30400		END